home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / CW MacMindy 1.4 / Examples / Pawns / pawns.dyl next >
Encoding:
Text File  |  1995-11-13  |  22.5 KB  |  701 lines  |  [TEXT/CWIE]
  1. library:        Erix
  2. module:            Pawns
  3. author:         Enrico Colombini (erix@mclink.it)
  4. copyright:      (C) 1994-95 Enrico Colombini
  5. version:        1.1,  9 Jan 1995
  6. synopsis:       A very simple board game that plays at random but learns 
  7.                 from its own mistakes, inspired by Martin Gardner's 
  8.                 "matchbox computer" in a 1969 issue of Scientific American.
  9.  
  10. // ======================================================================
  11. //
  12. // Copyright (c) 1994 Enrico Colombini
  13. // All rights reserved.
  14. //
  15. // This program can be freely distributed for non-commercial use,
  16. // provided that the following conditions are observed:
  17. //
  18. // 1. This copyright notice must be retained in full on any copies
  19. //    and on appropriate parts of any derivative works.
  20. // 2. No money can be charged for this program, with the possible
  21. //    exception of a reasonable distribution fee.
  22. // 3. Distribution of this program with commercial works of any type,
  23. //    including books and any other commercial publishing medium, is
  24. //    subjected to licensing from the author.
  25. // 4. This program can be included in CD-ROM freeware and/or shareware
  26. //    collections, as long as they do not contain any commercial software
  27. //    and are not distributed together with commercial works of any kind. 
  28. //
  29. // This software is made available "as is". The author does not
  30. // make any warranty about the software, its performance, or its 
  31. // conformity to any specification.
  32. // This is especially true because this program is designed as an
  33. // experimental, educational example, not as a "real-world application".
  34. //
  35. // Bug reports, questions, comments and suggestions could be sent by
  36. // E-mail to the Internet address "erix@mclink.it".
  37. //
  38. // ======================================================================
  39. //
  40. // This Dylan program is designed to be used with the Mindy compiler
  41. // and libraries publicly available from Carnegie Mellon University.
  42. // Version 1.2 of Mindy is required.
  43. //
  44. // ======================================================================
  45.  
  46.  
  47. // ======================================================================
  48. //                              History 
  49. // ======================================================================
  50. //
  51. // v 1.1  (9 Jan 1995):
  52. //  - updated Pawns to work with Mindy 1.2:
  53. //  - added argv0 to main()
  54. //  - updated module and library declarations
  55. //  - changed putc() to write-std() in input-move()
  56. //  - added *standard-output* to print() calls, added '\n'
  57. //  - added random-uniform-workaround for problem in Mindy 1.2 Random lib
  58. //
  59. // v 1.0  (18 Dec 1994):
  60. //  - first public version, works with Mindy 1.1
  61. //
  62.  
  63.  
  64. //////////////////////////////////////////////////////////////////////////
  65. //                            Modules & Co.                             //
  66. //////////////////////////////////////////////////////////////////////////
  67.  
  68. // The program stays in the single module Pawns in my library Erix
  69.  
  70. define library Erix
  71.   use Dylan;
  72.   use Streams;
  73.   use Print;
  74.   use Random;
  75. end;
  76.  
  77. define module Pawns
  78.   use Dylan;
  79.   use Extensions;
  80.   use Streams;
  81.   use Print;
  82.   use Random;
  83.   use Standard-IO;
  84. end;
  85.  
  86.  
  87. //////////////////////////////////////////////////////////////////////////
  88. //                              Constants                               //
  89. //////////////////////////////////////////////////////////////////////////
  90.  
  91. define constant <board> = <array>;
  92. define constant <packed-board> = <string>;
  93.  
  94. define constant $size-x-range :: <range> = range (from: 3, to: 6);
  95. define constant $size-y-range :: <range> = range (from: 3, to: 6);
  96.  
  97. define constant $empty :: <character> = ' ';
  98. define constant $human :: <character> = 'o';
  99. define constant $machine :: <character> = 'x';
  100.  
  101. define constant $command-line-help =
  102.   "\nusage:  pawns [-d] x y\n\n"
  103.   "        -d  deterministic play\n"
  104.   "         x  board horizontal size (3..6)\n"
  105.   "         y  board vertical size (3..6)\n";
  106.  
  107. define constant $opening-titles =
  108.   "\n\n           ===  Pawns 1.1  ===\n\n"
  109.   "(C) 1994-95 Enrico Colombini, all rights reserved\n"
  110.   "distribution free for non-commercial use only\n\n";
  111.  
  112. define constant $help-message = 
  113.   " Valid commands:\n"
  114.   "   save    save accumulated experience to disk\n"
  115.   "   load    reload previously saved experience\n"
  116.   "   reset   forget accumulated experience\n"
  117.   "   random  toggle random play mode\n"
  118.   "   quit    exit program\n\n";
  119.   // "help" is automatic
  120.   // undocumented commands: "exp", "debug", "nodebug"
  121.  
  122. define constant $human-comments = 
  123.   #[  "but I'm learning", "I don't understand", "something's wrong here",
  124.       "I'll be back", "just wait and see", "grumpf", "I've let you win",
  125.       "very strange", "I'll fire my programmer", "it won't happen again",
  126.       "practice makes perfect", "drat", "mmmmm", "just warming up",
  127.       " :-( :-( :-( ", "Are you happy now?", "how peculiar", "###CENSORED###",
  128.       "oh, no", "I'm sure you cheated", "beginner's luck", "not my day",
  129.       "I did it on purpose", "I'll call my mom", "not again", "why?",
  130.       "it was a power glitch", "probably a hardware fault", "oops"  ];
  131.       
  132. define constant $machine-comments =
  133.   #[  "as usual", "take that", "don't be so unhappy", "please stop crying",
  134.       "practice makes perfect", "well, well", " :-) :-) :-) ", "good",
  135.       "maybe you've been badly programmed", "learn this lesson", "he, he, he",
  136.       "I'm still the best", "put down that hammer, please", "smack",
  137.       "your AI must be defective", "I think you're just a human", "wow!",
  138.       "try raising your supply voltage", "it's been a pleasure",
  139.       "eat flaming silicon", "play again with me", "no surprise here",
  140.       "is your FDIV correct?", "don't reset me now", "I like this"  ];
  141.  
  142.  
  143. //////////////////////////////////////////////////////////////////////////
  144. //                             Global data                              //
  145. //////////////////////////////////////////////////////////////////////////
  146.  
  147. define variable *board* :: <board> = #[];
  148. define variable *board-size-x* :: <integer> = 0;
  149. define variable *board-size-y* :: <integer> = 0;
  150. define variable *last-board* :: <packed-board> = "";
  151. // list of losing board configurations:
  152. define variable *experience* :: <list> = #();
  153. define variable *random-play* :: <boolean> = #t;
  154. define variable *debug* :: <boolean> = #f;
  155.  
  156. define method enemy (actor == $human) $machine; end;
  157. define method enemy (actor == $machine) $human; end;
  158.  
  159.  
  160. //////////////////////////////////////////////////////////////////////////
  161. //                             Main program                             //
  162. //////////////////////////////////////////////////////////////////////////
  163.  
  164. define method main (argv0, #rest args)
  165.   if (apply (get-command-args, args) = #f)
  166.     write-std ($command-line-help);
  167.   else
  168.     // seed-random! (1995);    // any integer will do
  169.     let board-size = list (*board-size-x*, *board-size-y*);
  170.     *board* := make (<board>, dimensions: board-size);
  171.     write-std ($opening-titles);
  172.     write-flag-state (*random-play*, "Random play mode");
  173.     while (play-a-game () ~= #"quit") 
  174.       press-return ("Press <return> for next game");
  175.     end;
  176.     write-std-flush ("--> bye!\n");
  177.   end if;
  178. end method main;
  179.  
  180.  
  181. // Read command line args, set corresponding global vars, return #f if invalid
  182.  
  183. define method get-command-args (#rest args) => result :: <boolean>;
  184.   let ok = #f;
  185.   let args-list = as (<list>, args);
  186.   if (empty? (args-list)) args-list := #("3", "3"); end;    // <pcb> a hack to get default play.
  187.   if (~ empty? (args-list) & head (args-list) = "-d")
  188.     *random-play* := #f;
  189.     args-list := tail (args-list);
  190.   end if;
  191.   if (size (args-list) = 2)
  192.     let x = as (<integer>, (first (args-list))[0]) - as (<integer>, '0');
  193.     let y = as (<integer>, (second (args-list))[0]) - as (<integer>, '0');
  194.     if (member? (x, $size-x-range) & member? (y, $size-y-range))
  195.       *board-size-x* := x;
  196.       *board-size-y* := y;
  197.       ok := #t
  198.     end if;
  199.   end if;
  200.   ok;
  201. end method get-command-args;
  202.  
  203.  
  204. // Play a game until somebody wins or player quits 
  205. // exit status: winner (#"human" | #"machine"), or #"quit"
  206.  
  207. define method play-a-game () => result :: <symbol>;
  208.   reset-board ();
  209.   write-board ();
  210.   let status = #f;
  211.   until (status)
  212.     let (cmd, dest) = input-move ();
  213.     if (dest ~= "")
  214.       if (valid-human-move? (cmd, dest))
  215.     status := play-turn (cmd, dest);    
  216.       end if;
  217.     elseif (exec-command (cmd))
  218.       status := #"quit";
  219.     end if;
  220.   end until;
  221.   status;
  222. end method play-a-game;
  223.  
  224.  
  225. // Execute command (if valid), return #t if quit requested
  226.  
  227. define method exec-command (cmd :: <string>) => result :: <boolean>;
  228.   let quit-request = #f;
  229.   select (cmd by \=)    
  230.     "save" => 
  231.       save-experience ();
  232.       write-board ();
  233.     "load" => 
  234.       load-experience();
  235.       write-board();
  236.     "reset" => 
  237.       forget-experience();
  238.     "random" =>
  239.       *random-play* := ~ *random-play*;
  240.       write-flag-state (*random-play*, "Random play");
  241.     "quit" => 
  242.       quit-request := #t;
  243.     // undocumented commands:
  244.     "exp" => 
  245.       print (*experience*, *standard-output*); 
  246.       write-std ("\n\n");
  247.     "debug" => 
  248.       *debug* := ~ *debug*;
  249.       write-flag-state (*debug*, "Debug mode");
  250.     otherwise =>
  251.       write-std ($help-message);
  252.       write-board ();
  253.   end select;
  254.   quit-request;
  255. end method exec-command;
  256.  
  257.  
  258. // Write description of current state of a flag
  259.  
  260. define method write-flag-state (flag :: <boolean>, desc :: <string>)
  261.   write-std (' ', desc, ": ", if (flag) "on"; else "off"; end, "\n\n");
  262. end method write-flag-state;
  263.  
  264.  
  265. // Input move (2 tokens) or command (1 token)
  266.  
  267. define method input-move ()
  268.  => (cmd :: <string>, dest :: <string>);
  269.   write-std-flush ("Move (e.g. a1 a2): ");
  270.   // read-line will signal at eof, no need to check for #f
  271.   let line = as-lowercase (read-line (*standard-input*));
  272.   write-std ('\n');
  273.   let (token-1, pos) = get-token (line, 0);
  274.   let token-2 = get-token (line, pos);
  275.   values (token-1, token-2);
  276. end method input-move;
  277.  
  278.  
  279. // Check if valid move for human player, #f and print message if not valid
  280.  
  281. define method valid-human-move? (start :: <string>, dest :: <string>)
  282.  => result :: <boolean>;
  283.   let (x1, y1) = name-to-coords (start);
  284.   let (x2, y2) = name-to-coords (dest);
  285.   let valid = #f;
  286.   case 
  287.     ~ valid-square-coords? (x1, y1)
  288.       => write-std ("- <", start, "> is not a valid square\n\n");
  289.     *board*[x1, y1] ~= $human
  290.       => write-std ("- You don't have a pawn in square <", start, ">\n\n");
  291.     ~ valid-square-coords? (x2, y2)
  292.       => write-std ("- Invalid destination square <", dest, ">\n\n");
  293.     ~ member? (list (x2, y2), valid-moves-from (x1, y1), test: \=)
  294.       => write-std ("- Move forward in a free square or eat diagonally\n\n");
  295.     otherwise
  296.       => valid := #t;
  297.   end case;
  298.   unless (valid)
  299.     write-board ();
  300.   end unless;
  301.   valid;
  302. end method valid-human-move?;
  303.  
  304.  
  305. //////////////////////////////////////////////////////////////////////////
  306. //                               Game                                   //
  307. //////////////////////////////////////////////////////////////////////////
  308.  
  309. // Play a game turn starting with valid move, return winner or #f if none
  310.  
  311. define method play-turn (start :: <string>, dest :: <string>)
  312.  => result :: union (<symbol>, singleton (#f));
  313.   let winner = human-turn (start, dest) | machine-turn ();
  314.   if (winner = #"human") 
  315.     // last board was a losing one, add it to *experience*
  316.     add-losing-board (*last-board*);
  317.   elseif (~ winner)
  318.     // remember board after machine normal move
  319.     *last-board* := pack-board (*board*);
  320.   end if;
  321.   winner;
  322. end method play-turn;
  323.  
  324.  
  325. // Execute valid human move, return winner or #f
  326.  
  327. define method human-turn (start :: <string>, dest :: <string>)
  328.  => result :: union (<symbol>, singleton (#f));
  329.   let winner = #f;
  330.   let (x1, y1) = name-to-coords (start);
  331.   let (x2, y2) = name-to-coords (dest);
  332.   move-pawn (x1, y1, x2, y2);
  333.   write-board ();
  334.   // if last row reached, victory
  335.   if (y2 = *board-size-y* - 1)
  336.     winner := victory (#"human", "You have won this game"); 
  337.   end if;
  338.   winner;
  339. end method human-turn;
  340.  
  341.  
  342. // Build (possibly empty) list of valid destination squares from 
  343. // (valid, occupied) square, works for both human and machine
  344.  
  345. define method valid-moves-from (x :: <integer>, y :: <integer>)
  346.  => result :: <list>;
  347.   let actor = *board*[x, y];
  348.   let y = if (actor = $human) y + 1; else y - 1; end;
  349.   let valid-moves = #();
  350.   if (valid-square-coords? (x, y) & *board*[x, y] = $empty)
  351.     valid-moves := add! (valid-moves, list (x, y));
  352.   end if;
  353.   for (px from x - 1 to x + 1 by 2)
  354.     if (valid-square-coords? (px, y) & *board*[px, y] = enemy (actor))
  355.       valid-moves := add! (valid-moves, list (px, y));
  356.     end if;
  357.   end for;
  358.   valid-moves;
  359. end method valid-moves-from;
  360.  
  361.  
  362. // Build a list of all possible moves for actor's pawns, in form (x1,y1,x2,y2)
  363.  
  364. define method possible-moves (actor :: <character>) => moves :: <list>;
  365.   let moves = #();
  366.   let pawns = pawns-list (actor);
  367.   for (i in pawns)
  368.     let x1 = first (i);
  369.     let y1 = second (i);
  370.     let valid = valid-moves-from (x1, y1);
  371.     for (m in valid)
  372.       moves := add! (moves, list (x1, y1, first (m), second (m)));
  373.     end for;
  374.   end for;
  375.   moves;
  376. end method possible-moves;
  377.  
  378.  
  379. // Show victory message with random comment, return winner arg
  380.  
  381. define method victory (winner :: <symbol>, message :: <string>)
  382.  => winner :: <symbol>;
  383.   let comments = 
  384.     if (winner = #"machine") $machine-comments; else $human-comments; end;
  385.   let r = random-uniform-workaround (0, size (comments) - 1); // for Mindy 1.2
  386.   write-std ("==>  ", message, "  <==   ...", comments [r], "...\n\n");
  387.   winner;
  388. end method victory;
  389.  
  390.  
  391. //////////////////////////////////////////////////////////////////////////
  392. //                        Machine Play & memory                         //
  393. //////////////////////////////////////////////////////////////////////////
  394.  
  395. // Machine player thinks and moves, return winner or #f
  396.  
  397. define method machine-turn () 
  398.  => result :: union (<symbol>, singleton (#f));
  399.   let winner = #f;
  400.   let choices = possible-moves ($machine);
  401.   if (empty? (choices))
  402.     winner := victory (#"human", "I cannot move! You win");
  403.   else
  404.     if (*random-play*)
  405.       choices := shuffle-list (choices);
  406.     end if;
  407.     let move = any? (non-losing-move, choices);
  408.     if (move = #f)
  409.       winner := victory (#"human", "This position is hopeless. I give up");
  410.     else
  411.       press-return ("Press <return> for my move");
  412.       apply (move-pawn, move);
  413.       write-board (); 
  414.       // if first row reached, victory
  415.       if (last (move) = 0)
  416.     winner := victory (#"machine", "I won!");
  417.       elseif (possible-moves($human) = #())
  418.     winner := victory (#"machine", "You cannot move. You have lost!");
  419.       end if;
  420.     end if;
  421.   end if;
  422.   winner;
  423. end method machine-turn;
  424.  
  425.  
  426. // Simulate move, return move if resulting board is not in losing list, else #f
  427.  
  428. define method non-losing-move (move :: <list>)
  429.  => result :: union (<list>, singleton (#f));
  430.   apply (move-pawn, move);
  431.   let packed = pack-board (*board*);
  432.   if (*debug*) 
  433.     print (move, *standard-output*); 
  434.     write-std ("   ");
  435.     print (packed, *standard-output*); 
  436.     write-std ("\n\n");
  437.   end if;
  438.   apply (undo-move-pawn, move);
  439.   if (member? (packed, *experience*, test: \=)) #f; else move; end;
  440. end method non-losing-move;
  441.  
  442.  
  443. // Add losing board to experience (losing list)
  444.  
  445. define method add-losing-board (losing :: <packed-board>)
  446.   *experience* := add! (*experience*, losing);
  447. end method add-losing-board;
  448.  
  449.  
  450. // Forget all accumulated experience (losing board configurations)
  451.  
  452. define method forget-experience ()
  453.   *experience* := #();
  454. end method forget-experience;
  455.  
  456.  
  457. //////////////////////////////////////////////////////////////////////////
  458. //                             Save/load                                //
  459. //////////////////////////////////////////////////////////////////////////
  460.  
  461. // Save the losing boards list from *experience* to a disk file
  462. // (overwrite file if it already exists, no error detection)
  463.  
  464. define method save-experience()
  465.   let outfile = 
  466.     make (<file-stream>, name: experience-file-name (), direction: #"output");
  467.   for (i in *experience*)
  468.     write-line (i, outfile);
  469.   end for;
  470.   close (outfile);
  471.   write-std ("Experience saved into \"", experience-file-name (), "\"\n\n");
  472. end method save-experience;
  473.  
  474.  
  475. // Load experience from disk file into *experience* 
  476. // (no error detection)
  477.  
  478. define method load-experience()
  479.   let infile = 
  480.     make (<file-stream>, name: experience-file-name (), direction: #"input");
  481.   let temp = #();
  482.   let line = #f;
  483.   while (line := read-line (infile, signal-eof?: #f))
  484.     temp := add! (temp, line);
  485.   end while;
  486.   close (infile);
  487.   write-std ("Experience read from \"", experience-file-name (), "\"\n\n");
  488.   *experience* := temp;
  489. end method load-experience;
  490.  
  491.  
  492. // Build experience file name according to current board size
  493.  
  494. define method experience-file-name () => name :: <string>;
  495.   let board-id = "0x0";
  496.   board-id [0] := as (<character>, as (<integer>, '0') + *board-size-x*);
  497.   board-id [2] := as (<character>, as (<integer>, '0') + *board-size-y*);
  498.   concatenate ("experience.", board-id);
  499. end method experience-file-name;
  500.  
  501.  
  502. //////////////////////////////////////////////////////////////////////////
  503. //                             Game board                               //
  504. //////////////////////////////////////////////////////////////////////////
  505.  
  506. // Write board and its contents to standard-output
  507.  
  508. define method write-board ()
  509.   // write a separation line
  510.   local method sep-line ()
  511.           write-std ("      +");
  512.       for (x from 0 below *board-size-x*)
  513.         write-std ("---+");
  514.       end for;
  515.       write-std ('\n');
  516.     end method sep-line;
  517.   // draw by row
  518.   for (y from *board-size-y* - 1 to 0 by -1)
  519.     sep-line ();
  520.     write-std ("   ", as (<character>, y + as (<integer>, '1')), "  | ");
  521.     for (x from 0 below *board-size-x*)
  522.       write-std (*board*[x, y], " | ");
  523.     end for;
  524.     write-std ('\n');
  525.   end for;
  526.   // bottom border
  527.   sep-line ();
  528.   write-std ("        ");
  529.   for (x from 0 below *board-size-x*)
  530.     write-std (as (<character>, x + as (<integer>, 'a')));
  531.     write-std ("   ");
  532.   end for;
  533.   write-std-flush ("\n\n");
  534. end method write-board;
  535.  
  536.  
  537. // Convert square name (e.g. "a1") to x,y coordinates, no validity check
  538.  
  539. define method name-to-coords (name :: <string>) 
  540.  => (x :: <integer>, y :: <integer>);
  541.   // return invalid coord if no possible valid name
  542.   if (size (name) ~= 2)
  543.     values (-1, -1);
  544.   else
  545.     values (as (<integer>, name[0]) - as (<integer>, 'a'),
  546.         as (<integer>, name[1]) - as (<integer>, '1'));
  547.   end if;
  548. end method name-to-coords;
  549.  
  550.  
  551. // Check validity of square coordinates
  552.  
  553. define method valid-square-coords? (x :: <integer>, y :: <integer>)
  554.  => result :: <boolean>;
  555.   x >= 0 & x < *board-size-x* & y >= 0 & y < *board-size-y*;
  556. end method valid-square-coords?;
  557.  
  558.  
  559. // Pack board into string for compact storing
  560.  
  561. define method pack-board (board :: <board>) => result :: <string>;
  562.   map-as (<string>, identity, board);
  563. end method pack-board;
  564.  
  565.  
  566. //////////////////////////////////////////////////////////////////////////
  567. //                           Pawns & moves                              //
  568. //////////////////////////////////////////////////////////////////////////
  569.  
  570. // Put all pawns in their starting positions
  571.  
  572. define method reset-board ()
  573.   fill! (*board*, $empty);
  574.   for (x from 0 below *board-size-x*)
  575.     *board*[x, 0] := $human;
  576.     *board*[x,*board-size-y* - 1] := $machine;
  577.   end for;
  578. end method reset-board;
  579.  
  580.  
  581. // Build list of pawns of given player as (x,y) coordinates
  582.  
  583. define method pawns-list (actor :: <character>) => coords :: <list>;
  584.   let pawns = #();
  585.   for (y from 0 below *board-size-y*)
  586.     for (x from 0 below *board-size-x*)
  587.       if (*board*[x, y] = actor) 
  588.     pawns := add! (pawns, list (x, y));
  589.       end if;
  590.     end for;
  591.   end for;
  592.   pawns;
  593. end method pawns-list;
  594.  
  595.  
  596. // Move pawn from x1,y1 to x2,y2
  597.  
  598. define method move-pawn (x1 :: <integer>, y1 :: <integer>, 
  599.              x2 :: <integer>, y2 :: <integer>)
  600.   *board*[x2, y2] := *board*[x1, y1];
  601.   *board*[x1, y1] := $empty;
  602. end method move-pawn;
  603.  
  604.  
  605. // Undo pawn move from x1,y1 to x2,y2
  606.  
  607. define method undo-move-pawn (x1 :: <integer>, y1 :: <integer>, 
  608.                   x2 :: <integer>, y2 :: <integer>)
  609.   let actor = *board*[x2, y2];
  610.   *board*[x1, y1] := actor;
  611.   *board*[x2, y2] := if (x1 = x2) $empty; else enemy (actor); end;
  612. end method undo-move-pawn;
  613.  
  614.  
  615. //////////////////////////////////////////////////////////////////////////
  616. //                             Utilities                                //
  617. //////////////////////////////////////////////////////////////////////////
  618.  
  619. // Get token from string, use space & tab as separators if not given
  620.  
  621. define method get-token (str :: <string>, start :: <integer>, #key separators)
  622.  => (token :: <string>, new-pos :: <integer>);
  623.   unless (separators) separators := " \t"; end;
  624.   // find start of token
  625.   let limit = size (str);
  626.   while (start < limit & member? (str[start], separators))
  627.     start := start + 1;
  628.   end while;
  629.   // find end of token
  630.   let pos = start;
  631.   while (pos < limit & ~ member? (str[pos], separators))
  632.     pos := pos + 1;
  633.   end while;
  634.   if (pos = start)
  635.     values ("", 0);
  636.   else
  637.     values (copy-sequence (str, start: start, end: pos), pos);
  638.   end if;
  639. end method get-token;
  640.  
  641.  
  642. // Write all arguments to standard output
  643.  
  644. define method write-std (#rest args)
  645.   for (i in args)
  646.     write (i, *standard-output*);
  647.   end for;
  648. end method write-std;
  649.  
  650.  
  651. // Write all arguments to standard output and flush output buffer
  652.  
  653. define method write-std-flush (#rest args)
  654.   apply (write-std, args);
  655.   force-output (*standard-output*);
  656. end method write-std-flush;
  657.  
  658.  
  659. // Show prompt, wait for return key, add a newline
  660.  
  661. define method press-return (prompt :: <string>)
  662.   write-std-flush (prompt, ": ");
  663.   read-line (*standard-input*);
  664.   write-std ('\n');
  665. end method press-return;
  666.  
  667.  
  668. // Shuffle list elements, return a new shuffled list
  669. // (more or less constant time implementation)
  670.  
  671. define method shuffle-list (ordered :: <list>) => result :: <list>;
  672. let shuffled = #();
  673.   let temp = map-as (<vector>, identity, ordered);
  674.   temp := shuffle-vector! (temp);
  675.   map-as (<list>, identity, temp);
  676. end method shuffle-list;
  677.  
  678.  
  679. // Randomly shuffle vector elements in the passed array
  680.  
  681. define method shuffle-vector! (vec :: <vector>) => result :: <vector>;
  682.   let limit = size (vec) - 1;
  683.   for (i from 0 to limit)
  684.     let j = random-uniform-workaround (0, limit);       // for Mindy 1.2
  685.     let temp = vec [i];
  686.     vec [i] := vec[j];
  687.     vec[j] := temp;  
  688.   end for;
  689.   vec;
  690. end method shuffle-vector!;
  691.  
  692.  
  693. // Workaround for random-uniform problem in Mindy 1.2 random library
  694. //            (does not work if args are of <fixed-integer> type)
  695.  
  696. define method random-uniform-workaround (min :: <integer>, max :: <integer>)
  697.   => result :: <integer>;
  698.   // round (random-uniform (from: as (<float>, min), to: as (<float>, max)));
  699.   round (random-float (max));
  700. end method random-uniform-workaround;
  701.